(load "F:/class/NLPLab/workspace/nlp-lab/glr/given-code.lisp")

(load-lexicon "F:/class/NLPLab/workspace/nlp-lab/glr/glr-lexicon.lisp")
(load-semantics "F:/class/NLPLab/workspace/nlp-lab/glr/glr-semantics.lisp")
(loadgra "F:/class/NLPLab/workspace/nlp-lab/glr/glr-grammar")

(defun filter-lexicon (root+forms &aux result)
  (dolist (root+form root+forms)
    (when (not (null (gethash (first root+form) *synlex*)))
      (setf result (append result (list root+form)))))
  result)

;;;
;;;  Inflect nouns and verbs
;;;  Assigns agreement features for N and V, depending on presence or
;;;  absence of +S morpheme and/or explicit lexical features:
;;;  
;;;   N: 
;;;     - Defaults to (PERSON 3), unless feature supplied by lexicon
;;;     - Defaults to (NUMBER SG), unless:
;;;              * feature supplied by lexicon
;;;              * +S is present -> (NUMBER PL)
;;;   V: 
;;;     - If +S present, (PERSON 3), else will unify with any SUBJ
;;;       (functionally the same as (*OR* 1 2 3)
;;;     - Defaults to (NUMBER PL), unless:
;;;              * feature supplied by the lexicon
;;;              * +S is present -> (NUMBER SG)
;;;
(defun inflect-with (fs extension)
  (append extension fs))

(defun inflex-fs (form fs &aux pos extension)
  (setf pos (second (second fs)))
  (setf extension
        (case pos
          (N (case form
               (+NIL '((PERSON 3) (NUMBER SG)))
               (+S '((NUMBER PL)))))
          (V (case form
               (+NIL '((NUMBER PL)))
               (+S '((PERSON 3) (NUMBER SG)))))
          (t nil)))
  (inflect-with fs extension))

(defun inflex-fslist (form fs-list &aux result)
  (dolist (fs fs-list)
    (setf result (append result (list (inflex-fs form fs)))))
  result)

(defun inflect-lex (root form)
  (if (equal root "men")
      (list (inflect-with (gethash root *synlex*) '((NUMBER PL))))
      (inflex-fslist form (gethash root *synlex*))))

(defun inflect-lex-list (root+forms &aux result)
  (dolist (root+form root+forms)
    (let* ((root (first root+form))
           (form (second root+form)))
      (setf result (append result (inflect-lex root form)))))
  result)

;;;
;;;  PARSE-ENG-WORD takes a word in any form, analyzes its morphology,
;;;  looks up the dictionary, and returns a f-structure.
;;;  
(defun parse-eng-word (word &aux root+forms result-fs)
  
  ; 1. Use the built-in function parse-eng-morph to return the set of 
  ;    ("root" morph) pairs that are possible for the word;
  (setq root+forms (parse-eng-morph word))
  
  ; 2. Look up each root form in the lexicon to see if it exists;
  (setq root+forms (filter-lexicon root+forms))
  
  ; 3. If a morpheme was found attached to the root, inflect any lexical
  ;    entries appropriately.
  (setq result-fs (inflect-lex-list root+forms))
  
  ;(print result-fs)
  (list-to-value result-fs))


;------------------------------------------------------------

(defun get-n-pair (frame)
  (second (get-entry (second (second frame))))
  )

(defun get-v-pair (frame)
  (second frame)
  )

(defun semrole-filler-match (head-frame role filler-frame pos &aux head-pair filler-pair)
  (setf head-pair (case pos (N (get-n-pair head-frame)) (V (get-v-pair head-frame))))
  (setf filler-pair (get-n-pair filler-frame))
  
  (and
   (and
    (equal role (first head-pair))
    (equal role (first filler-pair)))
   (equal (second head-pair) (second filler-pair))))
  
;------------------------------------------------------------

(defun get-role (fs role)
  (dolist (f fs nil)
    (when (equal (first f) role)
      (return (second f)))))

(defun get-entry (sem)
  (gethash sem *semlex*))

(defun license-attachment (head filler &aux pos head-sem filler-sem head-frame role filler-frame license)
  (print head)
  (print filler)
  
  (setf pos (get-role head 'cat))
  (setf head-sem (get-role head 'sem))
  (setf role (get-role filler 'semrole))
  (setf filler-sem (get-role (get-role filler 'obj) 'sem))
   
  (setf head-frame (get-entry head-sem))
  (setf filler-frame (get-entry filler-sem))
  
  (setf license
        (if (equal (first role) '*OR*)
            (dolist (rl (rest role) nil)
              (when (semrole-filler-match head-frame rl filler-frame pos)
                (setf role rl)
                (return t)))
            (semrole-filler-match head-frame role filler-frame pos)))
  
  (print (append (if license (list '** 'ATTACHING) (list '** 'ATTACH 'FAILED)) 
                 (list "(" head-sem "(" role filler-sem "))")))
  
  license)

